Tcl set ret {}

proc r> {} {
	set r [lindex $::ret end]
	set ::ret [lreplace $::ret end end]
	return $r 
}

proc >r {p} {
	lappend ::ret $p
}

code .r ( -- )
	foreach r $::ret {
		puts -nonewline "$r "
	}
	puts ""

code !r ( -- )
	set ::ret ""
	puts ""

code or ( n1 n2 -- n3 )
	set n3 [expr $n1 || $n2]

code and ( n1 n2 -- n3 )
	set n3 [expr $n1 && $n2]

code not ( n1 -- n2 )
	set n2 [expr {!$n1}]

code == ( n1 n2 -- flag )
	set flag [expr {$n1==$n2}]

code = ( n1 n2 -- flag )
	set flag [expr {$n1==$n2}]

code >= ( n1 n2 -- flag )
	set flag [expr {$n1>=$n2}]

code <= ( n1 n2 -- flag )
	set flag [expr {$n1<=$n2}]

code < ( n1 n2 --  )
	push [expr {$n1<$n2}]

code > ( n1 n2 -- flag )
	set flag [expr {$n1>$n2}]

code != ( n1 n2 -- flag )
	set flag [expr {$n1!=$n2}]

code <> ( n1 n2 -- flag )
	set flag [expr {$n1!=$n2}]

code 0= ( n1 -- flag )
	set flag [expr {$n1==0}]

code 0< ( n1 -- flag )
	set flag [expr {$n1<0}]

code 0> ( n -- flag )
	set flag [expr {$n>0}]

Compiler "" 
	appendcode "puts \"\" ; "

Compiler \	SkipLine

code endchar ( s -- c )
	set c [string index $s end]

code tolower ( C -- c )
	set c [string tolower $C]

Compiler split    
	appendcode { foreach {j} [split [pop] [pop]] {push $j} ; }

code uppercase? ( c -- f )
	set f [regexp {[A-Z]} $c]

Compiler { PushList

Compiler {} 
	appendcode "push \{\} ; "

code end ( list -- e )
	set e [lindex $list end]

proc lrevert list {
	set res {}
	set i [llength $list]
	while {$i} {lappend res [lindex $list [incr i -1]]}
	return $res
 }

proc !list {obj i} {
	 upvar #0 $obj object
	 set object [lreplace $object $i $i [pop]]
}

proc @list {obj i} {
	push [lindex $obj $i]
}

Compiler Message MakeMessage

Message add

Message append

Message clear

Message close

Message count

Message eof

Message delete

Message get

Message getlist

Message incr

Message index

Message insert

Message length

Message name

Message names

Message newname

Message open-r

Message open-w

Message pop

Message print

Message push

Message put

Message revert

Message search

Message set

Message setlist

Message sort

Message @

Message !

Compiler Objecttype MakeObjecttype

Objecttype array   
set array(instance) {array set obj [pop]}

set array() {push $obj([pop])}
set array(get) {push $obj([pop])}
set array(@) {push $obj([pop])}
set array(put) {set obj([pop]) [pop]}
set array(!) {set obj([pop]) [pop]}
set array(set) {set obj([pop]) [pop]}
set array(incr) {incr obj([pop])}
set array(add) {incr obj([pop]) [pop]}
set array(print) {puts -nonewline $obj([pop])}
set array(names) {push [array names obj]}

Objecttype matrix   
set matrix(instance) {set obj() ""}

set matrix() {push $obj([pop],[pop])}
set matrix(get) {push $obj([pop],[pop])}
set matrix(@) {push $obj([pop],[pop])}
set matrix(put) {set obj([pop],[pop]) [pop]}
set matrix(!) {set obj([pop],[pop]) [pop]}
set matrix(set) {set obj([pop],[pop]) [pop]}
set matrix(incr) {incr obj([pop],[pop])}
set matrix(add) {incr obj([pop],[pop]) [pop]}
set matrix(print) {puts -nonewline $obj([pop],[pop])}

Objecttype string   
set string(instance) {set obj [pop]}

set string() {push $obj}
set string(get) {push $obj}
set string(put) {set obj [pop]}
set string(!) {set obj [pop]}
set string(set) {set obj [pop]}
set string(index) {push [string index $obj [pop]]}
set string(length) {push [string length $obj]}
set string(tolower) {push [string tolower $obj]}
set string(append) {append obj [pop]}

Objecttype list   
set list(instance) {set obj [pop]}

set list(index) {@list $obj [pop]}
set list(@) {@list $obj [pop]}  ;# get element i 
set list() {@list $obj [pop]}  ;# get element i  
set list(put) {!list obj [pop]} ;# set element i
set list(!) {!list obj [pop]}   ;# set element i
set list(set) {!list obj [pop]}   ;# set element i
set list(getlist) {push $obj}  ;# get full list
set list(setlist) {set obj [pop]}  ;# set full list
set list(append) {lappend obj [pop]}
set list(push) {lappend obj [pop]}
set list(pop) {push [lindex $obj end]; set obj [lreplace $obj end end]}
set list(length) {push [llength $obj]}
set list(clear) {set obj ""}
set list(revert) {set obj [lrevert $obj]}
set list(sort) {set obj [lsort $obj]}
set list(print) {puts $obj}
set list(search) {push [lsearch $obj [pop]]}

Objecttype file  
set file(instance) {set obj "[pop] handle" ; }

set file() {@list $obj 1}   ;# returns handle
set file(name) {@list $obj 0}
set file(newname) {!list obj 0}
set file(open-w) {push [open [lindex $obj 0] w]; !list obj 1 }
set file(open-r) {push [open [lindex $obj 0] r]; !list obj 1 }
set file(close) {close [lindex $obj 1]}
set file(put) {puts [lindex $obj 1] [pop]}
set file(get) {push [gets [lindex $obj 1]]}
set file(eof) {push [eof [lindex $obj 1]]}

Compiler cast
	set obj [GetItem]; set type [GetItem]
	if [isLocal $obj] {
		set locals($obj) $type
	} {
		error "only locals can be casted"
	}

Compiler case 
	appendcode "switch \[pop\]  \{\n"
	GetItem
	appendcode "$comp(word) "

Compiler of 
	appendcode "  \{ "

Compiler endof 
	appendcode " \}\n"
	GetItem
	if {$comp(word)!="endcase"} {
		appendcode "$comp(word) "
	} {
		appendcode "\}\n"
	}

Compiler endcase
	appendcode " \}\} \n \n "

Compiler foreach
	appendcode "foreach \[pop\] \[pop\] \{\n"

Compiler exit
	appendcode "return ; "

Compiler return
	appendcode "return ; "

Compiler begin
	appendcode "\nwhile 1 \{\n"

Compiler while
	appendcode "\nif \{\[pop\]==0\} break \n"

Compiler repeat
	appendcode \}\n

Compiler until
	appendcode "\nif \[pop\] break \}\n "

Compiler again
	appendcode \n\}\n

Compiler break
	appendcode "break ; "

Compiler do
	incr ::doi; incr ::doj; incr ::dok; 
	appendcode "set start$::doi \[pop\]; set limit$::doi \[pop\]; set incr$::doi 1
	for \{set _i$::doi \$start$::doi\} \{\$_i$::doi < \$limit$::doi \} \{incr _i$::doi \$incr$::doi  \} \{\n"

Compiler loop
	incr ::doi -1; incr ::doj -1; incr ::dok -1; 
	appendcode "\}\n"

Compiler +loop
	appendcode "set incr$::doi \[pop\]; \}\n"	
	incr ::doi -1; incr ::doj -1; incr ::dok -1;

Compiler doI 
	appendcode "push \$_i$::doi; "

Compiler doJ 
	appendcode "push \$_i$::doj; "

Compiler leave
	appendcode " break ;  "

Compiler times
	appendcode "set _t \[pop\]; while \{\$_t>0\} \{
	incr _t -1; "

code emit ( c -- )
	puts -nonewline [format %c $c]

code ascii ( c -- a )
	binary scan $c "c" a

Compiler asciiOf
	set c [GetItem]; set a [ascii $c]
	appendcode "push $a ; "

code char  ( a -- c )
	set c [format %c $a]

Compiler update
	appendcode " update ; "

Compiler doafter
	appendcode " after \[pop\] \[pop\] ;  "

Compiler sleep
	appendcode " after \[pop\] ;  "

Compiler wait
	appendcode " after \[pop\] \{set _ 0\}; vwait _

Compiler catch
	GetItem
	appendcode "if \{\[catch $comp(word) result\]\} \{
	puts \$result; 
	\}
	"

Compiler error"
	PushText
	appendcode " error \[pop\] ; "

code ErrorMsg ( text -- ) 
	error $text

